﻿Public Class Sudoku
    Inherits Puzzle

    Public Sub New()
        Size = 9
    End Sub

    Public Overrides Sub Draw()
        MyBase.Draw()
        For Each r In From y In Range(0, 2) From x In Range(0, 2)
            DrawRect(r.x * 3 + 1, r.y * 3 + 1, 3, 3, 1)
        Next
    End Sub

    Public Overrides Sub NewPuzzle()
        MyBase.NewPuzzle()
        Groups = New Groups(From t In Range(1, 3) From i In Range(1, Size) Let Group = New Group(t, i, Cells.Where(Function(c) c.Index(t) = i)) Select Group)
        For Each Item In Cells
            Dim Cell = Item
            Cell.Groups.Add((From g In Groups Where g.Type = 1 And g.Index = Cell.x).First)
            Cell.Groups.Add((From g In Groups Where g.Type = 2 And g.Index = Cell.y).First)
            Cell.Groups.Add((From g In Groups Where g.Type = 3 And g.Index = Cell.b).First)
        Next
    End Sub

    Public Overrides Sub NewCell(ByVal Cell As Cell)
        MyBase.NewCell(Cell)
        Cell.b = ((Cell.y - 1) \ 3) * 3 + (((Cell.x - 1) Mod 9) \ 3) + 1
    End Sub

    Public Overrides Function OnKeyPress(ByVal Key As String) As Boolean
        Select Case Key
            Case "1" To "9"
                CursorCell.g = Key
                If AutosolveMode Then Solve()
            Case "delete"
                CursorCell.g = ""
                If AutosolveMode Then Solve()
            Case Else
                Return MyBase.OnKeyPress(Key)
        End Select
    End Function

    Public Overrides Sub Load(ByVal Data As String)
        NewPuzzle()
        For i As Integer = 1 To 81
            Dim Cell As Cell = Cells(i - 1)
            Cell.g = Mid(Data, i, 1)
        Next
        Invalidate()
    End Sub

    Public Overrides Function Save() As String
        Return ""
    End Function

    Public Overrides Sub Solve()
        ClearLog()
        For Each Cell In Cells
            Cell.Reset("123456789")
        Next
        For Each Group In Groups
            Group.Reset()
        Next
        ProcessGiven()
        Dim Level As Integer = 1
        Dim Times(99) As Integer, Counts(99) As Integer
        Dim Watch As New Stopwatch
        Do
            Dim Progress As Boolean = False
            Watch.Reset()
            Watch.Start()
            Select Case Level
                Case 1 : Progress = NakedCandidates()
                Case 2 : Progress = SingleCandidates()
                Case 3 : Progress = CandidateLines()
                Case 4 : Progress = BlockPairs()
                Case 5 : Progress = NakedPairs()
                Case 6 : Progress = HiddenPairs()
                Case 7 : Progress = NakedTriples()
                Case 8 : Progress = HiddenTriplets()
                Case 9 : Progress = HiddenQuad()
                Case 10 : Progress = XWing()
                Case 11 : Progress = SwordFish()
                Case 12 : Progress = JellyFish()
                Case 13 : Progress = XYWing()
                Case 14 : Progress = XYZWing()
                Case 15 : Progress = Coloring()
                Case 16 : Progress = MultiColoring()
                Case 17 : Progress = XYChain()
                Case Else : If Not Progress Then Exit Do
            End Select
            Watch.Stop()
            Counts(Level) += 1
            Times(Level) += Watch.ElapsedMilliseconds
            Level = IIf(Progress, 1, Level + 1)
            FlushLog()
            If (From c As Cell In Cells Where c.f = "" Select c).Count = 0 Then Exit Do
        Loop
        Invalidate()
        Log.Append("")
        For i As Integer = 1 To 99
            If Counts(i) > 0 Then Log.Append(Choose(i, "naked candidates", "single candidates", "candidate lines", "block pairs", "naked pairs", "hidden pairs", "naked triplets", "hidden triplets", "hidden-quad", "x-wing", "swordfish", "jellyfish", "xy-wing", "xyz-wing", "coloring", "multicoloring", "xy-chain") & " : " & Counts(i) & " (" & Times(i) & "ms)")
        Next
        FlushLog()
        Invalidate()
    End Sub

    Sub ProcessGiven()
        For Each Result In From Cell In Cells Where Cell.Given Select Cell
            Result.SetValue(Result.g)
        Next
    End Sub

    Function CandidateLines() As Boolean
        Dim Progress As Boolean = False
        For Each Result In _
                From c1 In Cells From ch In c1.Candidates From d In c1.LDirections _
                Where Not (From c2 In c1.Block Where c2(ch) And Not d.Contains(c2)).Any _
                From Cell In d Where Cell(ch) AndAlso Not Cell.Block.Contains(c1)
            Log.Append("candidate line at " & Result.c1 & " for " & Result.ch & " eliminating at " & Result.Cell)
            Result.Cell.Eliminate(Result.ch)
            Progress = True
        Next
        Return Progress
    End Function

    Function BlockPairs() As Boolean
        Dim Progress As Boolean = False
        For Each Result In _
                From c1 In Cells From ch In c1.Candidates From d In c1.LDirections _
                Where Not (From c2 In d Where c2(ch) And Not c1.Block.Contains(c2)).Any _
                From Cell In c1.Block Where Cell(ch) AndAlso Not d.Contains(Cell)
            Log.Append("block pair detected at " & Result.c1 & " for " & Result.ch)
            Result.Cell.Eliminate(Result.ch)
            Progress = True
        Next
        Return Progress
    End Function

    Function HiddenQuad() As Boolean
        Dim Progress As Boolean = False
        For Each Result In ( _
                From g In Groups From c1 In g.PossibleCells Where c1.Value.Count.Between(2, 4) _
                From c2 In g.PossibleCells Where c2.Value.Count.Between(2, 4) AndAlso c2.Key > c1.Key Let J12 = c1.Value.Union(c2.Value) Where J12.Count.Between(3, 4) _
                From c3 In g.PossibleCells Where c3.Value.Count.Between(2, 4) AndAlso c3.Key > c2.Key Let J123 = c3.Value.Union(J12) Where J123.Count = 4 _
                From c4 In g.PossibleCells Where c4.Value.Count.Between(2, 4) AndAlso c4.Key > c3.Key Let J1234 = c4.Value.Union(J123) Where J1234.Count = 4 _
                From c In g.PossibleCells Where c.Value.Intersect(J1234).Count > 0 AndAlso Not c.Key.In(c1.Key, c2.Key, c3.Key, c4.Key) Let Cell1 = J1234(0), Cell2 = J1234(1), Cell3 = J1234(2), Cell4 = J1234(3)).ToList
            Log.Append("hidden quad detected at " & Result.Cell1 & Result.Cell2 & Result.Cell3 & Result.Cell4 & " for " & Result.c1.Key & Result.c2.Key & Result.c3.Key & Result.c4.Key & " eliminating other values")
            Result.Cell1.Eliminate(Result.c.Key)
            Result.Cell2.Eliminate(Result.c.Key)
            Result.Cell3.Eliminate(Result.c.Key)
            Result.Cell4.Eliminate(Result.c.Key)
            Progress = True
        Next
    End Function

    Function XYWing() As Boolean
        Dim Progress As Boolean = False
        'For Each Result In _
        '        From c1 In Cells Where c1.Candidates.Count = 2 _
        '        From c2 In c1.LPeers Where c2.Candidates.Count = 2 Let C12 = c1 * c2 Where C12.Length = 1 _
        '        From c3 In c1.Peers.Except(c2.Peers) Where c3.Candidates.Count = 2 Let C13 = c1 * c3 Where C13.Length = 1 _
        '        Let C23 = c2 * c3 Where C23.Length = 1 AndAlso C13 <> C12 AndAlso C23 <> C12 AndAlso C23 <> C13 _
        '        From Cell In c2.Peers.Intersect(c3.Peers) Where Cell(C23)
        '    Log.Append("xy-wing detected at " & Result.c1 & Result.c2 & Result.c3 & " eliminating " & Result.C23 & " at " & Result.Cell)
        '    Result.Cell.Eliminate(Result.C23)
        '    Progress = True
        'Next
        Return Progress
    End Function

    Function XYZWing() As Boolean
        Dim Progress As Boolean = False
        For Each Result In _
                From c1 In Cells Where c1.Candidates.Count = 2 _
                From c2 In Cells.Except(c1.Peers) Where c2.Candidates.Count = 2 Let U12 = c1.CandidateStr.Add(c2.CandidateStr) Where U12.Length = 3 _
                From c3 In c1.Peers.Intersect(c2.Peers) Where c3.Candidates.Count = 3 AndAlso c3.CandidateStr = U12 _
                From Cell In c1.Peers.Intersect(c2.Peers).Intersect(c3.Peers) Let Common = c1 * c2 Where Cell(Common)
            Log.Append("xyz-wing detected at " & Result.c1 & Result.c2 & Result.c3 & " eliminating " & Result.Common & " at " & Result.Cell)
            Result.Cell.Eliminate(Result.Common)
            Progress = True
        Next
        Return Progress
    End Function

    Function Coloring() As Boolean
        Dim Progress As Boolean = False
        For Each Result In From Cell As Cell In Cells Where Cell.Candidates.Count = 2 From c In Cell.Candidates
            Progress = SearchColoringChain(Result.Cell, Result.c, Result.Cell, New List(Of Cell))
            If Progress Then Log.Append("coloring detected")
            If Progress Then Exit For
        Next
        Return Progress
    End Function

    Function MultiColoring() As Boolean
        Dim Progress As Boolean = False
        Dim Chains(9) As List(Of List(Of Cell))
        For i As Integer = 1 To 9
            Chains(i) = New List(Of List(Of Cell))
        Next
        For Each Result In ( _
                From Cell In Cells From c In Cell.Candidates From g In Cell.Groups Where g.PossibleCells(c).Count = 2 _
                From Candidate In g.PossibleCells(c) Where Candidate.i <> Cell.i Select Cell, c, Candidate).Distinct
            Dim Chain As New List(Of Cell)
            Chain.Add(Result.Cell)
            GetChain(Result.Candidate, Result.c, Chain)
            Log.Append("chain of " & Result.c & " " & PrintChain(Chain))
            Chains(Val(Result.c)).Add(Chain)
        Next
        For Each Result In ( _
                From d In Enumerable.Range(1, 9) From c1 In Chains(d) From c2 In Chains(d) Where Chains(d).IndexOf(c1) < Chains(d).IndexOf(c2) AndAlso c1(0).Peers.Contains(c2(0)) _
                From Cell1 In c1 From Cell2 In c2 Where c1.IndexOf(Cell1) Mod 2 = 1 AndAlso c2.IndexOf(Cell2) Mod 2 = 1 _
                From Cell In Cell1.Peers.Intersect(Cell2.Peers) Where Cell(d) Select c1, c2, d, Cell).Distinct
            Log.Append("multicoloring: " & PrintChain(Result.c1) & " and " & PrintChain(Result.c2) & " eliminates " & Result.d & " in " & Result.Cell)
            Result.Cell.Eliminate(Result.d)
            Progress = True
        Next
        Return Progress
    End Function

    Function PrintChain(ByVal Chain As List(Of Cell)) As String
        Dim Text As String = ""
        For Each Item In Chain
            Text &= Item.ToString
        Next
        Return Text
    End Function

    Function XYChain() As Boolean
        Dim Progress As Boolean = False
        For Each Result In From c As Cell In Cells.Empties Where c.Candidates.Count = 2 From rc In c.Candidates Let ch = (From ch In c.Candidates Where ch <> rc).First
            Dim History As New List(Of Cell)
            Progress = SearchXYChain(Result.c, Result.rc, Result.ch, Result.c, History)
            If Progress Then
                Dim Text As String = ""
                For Each Item In History
                    Text &= Item.ToString
                Next
                Log.Append("xy-chain detected " & Text)
            End If
            If Progress Then Exit For
        Next
        Return Progress
    End Function

    Public Overrides Sub Edit(ByVal Cmd As String)
        Select Case Cmd
            Case "clear"
                Undos.Add("a" & Save())
                NewPuzzle()
                Redos.Clear()
                Redos.Add("a" & Save())
            Case "copy"
                Clipboard.Clear()
                Clipboard.SetText(Save)
            Case "paste"
                Try
                    Undos.Add("a" & Save())
                    Load(Clipboard.GetText.Replace(".", " "))
                    Redos.Clear()
                    Redos.Add("a" & Save())
                Catch ex As Exception
                    Undos.RemoveAt(Undos.Count - 1)
                End Try
            Case Else
                MyBase.Edit(Cmd)
        End Select
    End Sub

    Function SearchColoringChain(ByVal Cell As Cell, ByVal ch As Char, ByVal Root As Cell, ByVal History As List(Of Cell)) As Boolean
        History.Add(Cell)
        If History.Count Mod 2 = 0 Then
            For Each res In From c In Cell.Peers.Intersect(Root.Peers) Where c(ch)
                res.Eliminate(ch)
                Return True
            Next
        End If
        For Each Candidate In From g In Cell.Groups Where g.PossibleCells(ch).Count = 2 From c In g.PossibleCells(ch) Where Not History.Contains(c) Select c
            If SearchColoringChain(Candidate, ch, Root, History) Then Return True
        Next
        History.Remove(Cell)
    End Function

    Sub GetChain(ByVal Cell As Cell, ByVal ch As Char, ByVal History As List(Of Cell))
        History.Add(Cell)
        Dim Candidates = (From g In Groups Where g.PossibleCells(ch).Count = 2 From c In g.PossibleCells(ch) Where Not History.Contains(c) Select c)
        If Candidates.Count = 1 Then GetChain(Candidates.Single, ch, History)
    End Sub

    Function SearchXYChain(ByVal Cell As Cell, ByVal rc As Char, ByVal ch As Char, ByVal Root As Cell, ByVal History As List(Of Cell)) As Boolean
        History.Add(Cell)
        If rc = ch Then
            Dim Found As Boolean
            For Each Result In From c In Cell.Peers.Intersect(Root.Peers) Where c(rc)
                Found = True
                Result.Eliminate(rc)
            Next
            If Found Then Return True
        End If
        For Each Result In From g In Cell.Groups From c In g.PossibleCells(ch).Empties.Except(History) Where c.Candidates.Count = 2 AndAlso Not History.Contains(c) Select c, cs = (From cs In c.Candidates Where cs <> ch).First
            If SearchXYChain(Result.c, rc, Result.cs, Root, History) Then Return True
        Next
        History.Remove(Cell)
    End Function

End Class




